home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / s-posrte.adb < prev    next >
Text File  |  1994-05-19  |  8KB  |  233 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --                      S Y S T E M . P O S I X _ R T E                     --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.6 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
  12. --                                                                          --
  13. --  GNARL is free software; you can redistribute it and/or modify it  under --
  14. --  terms  of  the  GNU  Library General Public License as published by the --
  15. --  Free Software Foundation; either version 2,  or (at  your  option)  any --
  16. --  later  version.   GNARL is distributed in the hope that it will be use- --
  17. --  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
  18. --  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. --  eral Library Public License for more details.  You should have received --
  20. --  a  copy of the GNU Library General Public License along with GNARL; see --
  21. --  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
  22. --  Ave, Cambridge, MA 02139, USA.                                          --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Unchecked_Conversion;
  27.  
  28. package body System.POSIX_RTE is
  29.  
  30.    type sigaction_ptr is access struct_sigaction;
  31.  
  32.    function Address_to_Pointer is new
  33.      Unchecked_Conversion (System.Address, sigaction_ptr);
  34.  
  35.    function Address_to_Pointer is new
  36.      Unchecked_Conversion (System.Address, sigset_t_ptr);
  37.  
  38.    function Address_to_Pointer is new
  39.      Unchecked_Conversion (System.Address, jmp_buf_ptr);
  40.  
  41.    function Address_to_Pointer is new
  42.      Unchecked_Conversion (System.Address, sigjmp_buf_ptr);
  43.  
  44.    --  The following are P1003.5 interfaces.  I am not sure that this is a
  45.    --  good idea, but these can't be exactly the same as the C functions
  46.    --  in any case.
  47.  
  48.    procedure Add_Signal (Set : in out Signal_Set; Sig : in Signal) is
  49.       function sigaddset (Set : sigset_t_ptr; Sig : Signal) return Integer;
  50.       pragma Import (C, sigaddset, "sigaddset");
  51.    begin
  52.       if sigaddset (Address_to_Pointer (Set'Address), Sig) /= 0 then
  53.          raise POSIX_Error.POSIX_Error;
  54.       end if;
  55.    end Add_Signal;
  56.  
  57.    procedure Delete_Signal (Set : in out Signal_Set; Sig : in Signal) is
  58.       function sigdelset (Set : sigset_t_ptr; Sig : Signal) return Integer;
  59.       pragma Import (C, sigdelset, "sigdelset");
  60.    begin
  61.       if sigdelset (Address_to_Pointer (Set'Address), Sig) /= 0 then
  62.          raise POSIX_Error.POSIX_Error;
  63.       end if;
  64.    end Delete_Signal;
  65.  
  66.    procedure Add_All_Signals (Set : in out Signal_Set) is
  67.       function sigfillset (Set : sigset_t_ptr) return Integer;
  68.       pragma Import (C, sigfillset, "sigfillset");
  69.    begin
  70.       if sigfillset (Address_to_Pointer (Set'Address)) /= 0 then
  71.          raise POSIX_Error.POSIX_Error;
  72.       end if;
  73.    end Add_All_Signals;
  74.  
  75.    procedure Delete_All_Signals (Set : in out Signal_Set) is
  76.       function sigemptyset (Set : sigset_t_ptr) return Integer;
  77.       pragma Import (C, sigemptyset, "sigemptyset");
  78.    begin
  79.       if sigemptyset (Address_to_Pointer (Set'Address)) /= 0 then
  80.          raise POSIX_Error.POSIX_Error;
  81.       end if;
  82.    end Delete_All_Signals;
  83.  
  84.    function Is_Member (Set : Signal_Set; Sig : Signal) return Boolean is
  85.       function sigismember (Set : sigset_t_ptr; Sig : Signal) return Integer;
  86.       pragma Import (C, sigismember, "sigismember");
  87.    begin
  88.       if sigismember (Address_to_Pointer (Set'Address), Sig) = 1 then
  89.          return True;
  90.       else
  91.          return False;
  92.       end if;
  93.    end Is_Member;
  94.  
  95.    --  End of P1003.5 interfaces.
  96.  
  97.    ---------------
  98.    -- sigaction --
  99.    ---------------
  100.  
  101.    procedure sigaction
  102.      (sig    : Signal;
  103.       act    : struct_sigaction;
  104.       oact   : out struct_sigaction;
  105.       Result : out POSIX_Error.Return_Code)
  106.    is
  107.       function sigaction_base
  108.         (sig  : Signal;
  109.          act  : sigaction_ptr;
  110.          oact : sigaction_ptr) return Return_Code;
  111.       pragma Import (C, sigaction_base, "sigaction");
  112.  
  113.    begin
  114.       Result := sigaction_base (sig, Address_to_Pointer (act'Address),
  115.             Address_to_Pointer (oact'Address));
  116.    end sigaction;
  117.  
  118.    -----------------
  119.    -- sigprocmask --
  120.    -----------------
  121.  
  122.    --  Install new signal mask and obtain old one
  123.  
  124.    procedure sigprocmask
  125.      (how    : Integer;
  126.       set    : Signal_Set;
  127.       oset   : out Signal_Set;
  128.       Result : out POSIX_Error.Return_Code)
  129.    is
  130.       function sigprocmask_base (how : Integer;
  131.             set : sigset_t_ptr;
  132.             oset : sigset_t_ptr) return Return_Code;
  133.       pragma Import (C, sigprocmask_base, "sigprocmask");
  134.  
  135.    begin
  136.       Result := sigprocmask_base (how, Address_to_Pointer (set'Address),
  137.             Address_to_Pointer (oset'Address));
  138.    end sigprocmask;
  139.  
  140.    ----------------
  141.    -- sigsuspend --
  142.    ----------------
  143.  
  144.    --  Suspend waiting for signals in mask and resume after
  145.    --  executing handler or take default action
  146.  
  147.    procedure sigsuspend (mask : Signal_Set; Result : out Return_Code) is
  148.       function sigsuspend_base (mask : sigset_t_ptr) return Return_Code;
  149.       pragma Import (C, sigsuspend_base, "sigsuspend");
  150.  
  151.    begin
  152.       Result := sigsuspend_base (Address_to_Pointer (mask'Address));
  153.    end sigsuspend;
  154.  
  155.    ----------------
  156.    -- sigpending --
  157.    ----------------
  158.  
  159.    --  Get pending signals on thread and process
  160.  
  161.    procedure sigpending (set : out Signal_Set; Result : out Return_Code) is
  162.       function sigpending_base (set : sigset_t_ptr) return Return_Code;
  163.       pragma Import (C, sigpending_base, "sigpending");
  164.  
  165.    begin
  166.       Result := sigpending_base (Address_to_Pointer (set'Address));
  167.    end sigpending;
  168.  
  169.    -------------
  170.    -- longjmp --
  171.    -------------
  172.  
  173.    --  Execute a jump across procedures according to setjmp
  174.  
  175.    procedure longjmp (env : jmp_buf; val : Integer) is
  176.       procedure longjmp_base (env : jmp_buf_ptr; val : Integer);
  177.       pragma Import (C, longjmp_base, "longjmp");
  178.  
  179.    begin
  180.       longjmp_base (Address_to_Pointer (env'Address), val);
  181.    end longjmp;
  182.  
  183.    ----------------
  184.    -- siglongjmp --
  185.    ----------------
  186.  
  187.    --  Execute a jump across procedures according to sigsetjmp
  188.  
  189.    procedure siglongjmp (env : sigjmp_buf; val : Integer) is
  190.       procedure siglongjmp_base (env : sigjmp_buf_ptr; val : Integer);
  191.       pragma Import (C, siglongjmp_base, "siglongjmp");
  192.  
  193.    begin
  194.       siglongjmp_base (Address_to_Pointer (env'Address), val);
  195.    end siglongjmp;
  196.  
  197.    ------------
  198.    -- setjmp --
  199.    ------------
  200.  
  201.    --  Set up a jump across procedures and return here with longjmp
  202.  
  203.    procedure setjmp (env : jmp_buf; Result : out Integer) is
  204.       function setjmp_base (env : jmp_buf_ptr) return Integer;
  205.       pragma Import (C, setjmp_base, "setjmp");
  206.  
  207.    begin
  208.       Result := setjmp_base (Address_to_Pointer (env'Address));
  209.    end setjmp;
  210.  
  211.    ---------------
  212.    -- sigsetjmp --
  213.    ---------------
  214.  
  215.    --  Set up a jump across procedures and return here with siglongjmp
  216.  
  217.    procedure sigsetjmp
  218.      (env      : sigjmp_buf;
  219.       savemask : Integer;
  220.       Result   : out Integer)
  221.    is
  222.       function sigsetjmp_base
  223.         (env      : sigjmp_buf_ptr;
  224.          savemask : Integer)
  225.          return     Integer;
  226.       pragma Import (C, sigsetjmp_base, "sigsetjmp");
  227.  
  228.    begin
  229.       Result := sigsetjmp_base (Address_to_Pointer (env'Address), savemask);
  230.    end sigsetjmp;
  231.  
  232. end System.POSIX_RTE;
  233.